home *** CD-ROM | disk | FTP | other *** search
/ Gigarom 1 / Gigarom Macintosh Archives (Quantum Leap)(CDRM1080320)(1993).iso / FILES / DEV / I-Z / Xlisp_Source.cpt / xlfio.c < prev    next >
Text File  |  1985-01-27  |  9KB  |  445 lines
  1. /* xlfio.c - xlisp file i/o */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *s_stdin,*s_stdout;
  7. extern NODE *xlstack;
  8. extern int xlfsize;
  9. extern char buf[];
  10.  
  11. /* external routines */
  12. extern FILE *fopen();
  13.  
  14. /* forward declarations */
  15. FORWARD NODE *printit();
  16. FORWARD NODE *flatsize();
  17. FORWARD NODE *explode();
  18. FORWARD NODE *implode();
  19. FORWARD NODE *openit();
  20. FORWARD NODE *getfile();
  21.  
  22. /* xread - read an expression */
  23. NODE *xread(args)
  24.   NODE *args;
  25. {
  26.     NODE *oldstk,fptr,eof,*val;
  27.  
  28.     /* create a new stack frame */
  29.     oldstk = xlsave(&fptr,&eof,NULL);
  30.  
  31.     /* get file pointer and eof value */
  32.     fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  33.     eof.n_ptr = (args ? xlarg(&args) : NIL);
  34.     xllastarg(args);
  35.  
  36.     /* read an expression */
  37.     if (!xlread(fptr.n_ptr,&val))
  38.     val = eof.n_ptr;
  39.  
  40.     /* restore the previous stack frame */
  41.     xlstack = oldstk;
  42.  
  43.     /* return the expression */
  44.     return (val);
  45. }
  46.  
  47. /* xprint - builtin function 'print' */
  48. NODE *xprint(args)
  49.   NODE *args;
  50. {
  51.     return (printit(args,TRUE,TRUE));
  52. }
  53.  
  54. /* xprin1 - builtin function 'prin1' */
  55. NODE *xprin1(args)
  56.   NODE *args;
  57. {
  58.     return (printit(args,TRUE,FALSE));
  59. }
  60.  
  61. /* xprinc - builtin function princ */
  62. NODE *xprinc(args)
  63.   NODE *args;
  64. {
  65.     return (printit(args,FALSE,FALSE));
  66. }
  67.  
  68. /* xterpri - terminate the current print line */
  69. NODE *xterpri(args)
  70.   NODE *args;
  71. {
  72.     NODE *fptr;
  73.  
  74.     /* get file pointer */
  75.     fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
  76.     xllastarg(args);
  77.  
  78.     /* terminate the print line and return nil */
  79.     xlterpri(fptr);
  80.     return (NIL);
  81. }
  82.  
  83. /* printit - common print function */
  84. LOCAL NODE *printit(args,pflag,tflag)
  85.   NODE *args; int pflag,tflag;
  86. {
  87.     NODE *oldstk,fptr,val;
  88.  
  89.     /* create a new stack frame */
  90.     oldstk = xlsave(&fptr,&val,NULL);
  91.  
  92.     /* get expression to print and file pointer */
  93.     val.n_ptr = xlarg(&args);
  94.     fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
  95.     xllastarg(args);
  96.  
  97.     /* print the value */
  98.     xlprint(fptr.n_ptr,val.n_ptr,pflag);
  99.  
  100.     /* terminate the print line if necessary */
  101.     if (tflag)
  102.     xlterpri(fptr.n_ptr);
  103.  
  104.     /* restore the previous stack frame */
  105.     xlstack = oldstk;
  106.  
  107.     /* return the result */
  108.     return (val.n_ptr);
  109. }
  110.  
  111. /* xflatsize - compute the size of a printed representation using prin1 */
  112. NODE *xflatsize(args)
  113.   NODE *args;
  114. {
  115.     return (flatsize(args,TRUE));
  116. }
  117.  
  118. /* xflatc - compute the size of a printed representation using princ */
  119. NODE *xflatc(args)
  120.   NODE *args;
  121. {
  122.     return (flatsize(args,FALSE));
  123. }
  124.  
  125. /* flatsize - compute the size of a printed expression */
  126. LOCAL NODE *flatsize(args,pflag)
  127.   NODE *args; int pflag;
  128. {
  129.     NODE *oldstk,val;
  130.  
  131.     /* create a new stack frame */
  132.     oldstk = xlsave(&val,NULL);
  133.  
  134.     /* get the expression */
  135.     val.n_ptr = xlarg(&args);
  136.     xllastarg(args);
  137.  
  138.     /* print the value to compute its size */
  139.     xlfsize = 0;
  140.     xlprint(NIL,val.n_ptr,pflag);
  141.  
  142.     /* restore the previous stack frame */
  143.     xlstack = oldstk;
  144.  
  145.     /* return the length of the expression */
  146.     val.n_ptr = newnode(INT);
  147.     val.n_ptr->n_int = xlfsize;
  148.     return (val.n_ptr);
  149. }
  150.  
  151. /* xexplode - explode an expression */
  152. NODE *xexplode(args)
  153.   NODE *args;
  154. {
  155.     return (explode(args,TRUE));
  156. }
  157.  
  158. /* xexplc - explode an expression using princ */
  159. NODE *xexplc(args)
  160.   NODE *args;
  161. {
  162.     return (explode(args,FALSE));
  163. }
  164.  
  165. /* explode - internal explode routine */
  166. LOCAL NODE *explode(args,pflag)
  167.   NODE *args; int pflag;
  168. {
  169.     NODE *oldstk,val,strm;
  170.  
  171.     /* create a new stack frame */
  172.     oldstk = xlsave(&val,&strm,NULL);
  173.  
  174.     /* get the expression */
  175.     val.n_ptr = xlarg(&args);
  176.     xllastarg(args);
  177.  
  178.     /* create a stream */
  179.     strm.n_ptr = newnode(LIST);
  180.  
  181.     /* print the value into the stream */
  182.     xlprint(strm.n_ptr,val.n_ptr,pflag);
  183.  
  184.     /* restore the previous stack frame */
  185.     xlstack = oldstk;
  186.  
  187.     /* return the list of characters */
  188.     return (car(strm.n_ptr));
  189. }
  190.  
  191. /* ximplode - implode a list of characters into a symbol */
  192. NODE *ximplode(args)
  193.   NODE *args;
  194. {
  195.     return (implode(args,TRUE));
  196. }
  197.  
  198. /* xmaknam - implode a list of characters into an uninterned symbol */
  199. NODE *xmaknam(args)
  200.   NODE *args;
  201. {
  202.     return (implode(args,FALSE));
  203. }
  204.  
  205. /* implode - internal implode routine */
  206. LOCAL NODE *implode(args,intflag)
  207.   NODE *args; int intflag;
  208. {
  209.     NODE *list,*val;
  210.     char *p;
  211.  
  212.     /* get the list */
  213.     list = xlarg(&args);
  214.     xllastarg(args);
  215.  
  216.     /* assemble the symbol's pname */
  217.     for (p = buf; consp(list); list = cdr(list)) {
  218.     if ((val = car(list)) == NIL || !fixp(val))
  219.         xlfail("bad character list");
  220.     if ((int)(p - buf) < STRMAX)
  221.         *p++ = val->n_int;
  222.     }
  223.     *p = 0;
  224.  
  225.     /* create a symbol */
  226.     val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));
  227.  
  228.     /* return the symbol */
  229.     return (val);
  230. }
  231.  
  232. /* xopeni - open an input file */
  233. NODE *xopeni(args)
  234.   NODE *args;
  235. {
  236.     return (openit(args,"r"));
  237. }
  238.  
  239. /* xopeno - open an output file */
  240. NODE *xopeno(args)
  241.   NODE *args;
  242. {
  243.     return (openit(args,"w"));
  244. }
  245.  
  246. /* openit - common file open routine */
  247. LOCAL NODE *openit(args,mode)
  248.   NODE *args; char *mode;
  249. {
  250.     NODE *fname,*val;
  251.     FILE *fp;
  252.  
  253.     /* get the file name */
  254.     fname = xlmatch(STR,&args);
  255.     xllastarg(args);
  256.  
  257.     /* try to open the file */
  258.     if ((fp = fopen(fname->n_str,mode)) != NULL) {
  259.     val = newnode(FPTR);
  260.     val->n_fp = fp;
  261.     val->n_savech = 0;
  262.     }
  263.     else
  264.     val = NIL;
  265.  
  266.     /* return the file pointer */
  267.     return (val);
  268. }
  269.  
  270. /* xclose - close a file */
  271. NODE *xclose(args)
  272.   NODE *args;
  273. {
  274.     NODE *fptr;
  275.  
  276.     /* get file pointer */
  277.     fptr = xlmatch(FPTR,&args);
  278.     xllastarg(args);
  279.  
  280.     /* make sure the file exists */
  281.     if (fptr->n_fp == NULL)
  282.     xlfail("file not open");
  283.  
  284.     /* close the file */
  285.     fclose(fptr->n_fp);
  286.     fptr->n_fp = NULL;
  287.  
  288.     /* return nil */
  289.     return (NIL);
  290. }
  291.  
  292. /* xrdchar - read a character from a file */
  293. NODE *xrdchar(args)
  294.   NODE *args;
  295. {
  296.     NODE *fptr,*val;
  297.     int ch;
  298.  
  299.     /* get file pointer */
  300.     fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  301.     xllastarg(args);
  302.  
  303.     /* get character and check for eof */
  304.     if ((ch = xlgetc(fptr)) == EOF)
  305.     val = NIL;
  306.     else {
  307.     val = newnode(INT);
  308.     val->n_int = ch;
  309.     }
  310.  
  311.     /* return the character */
  312.     return (val);
  313. }
  314.  
  315. /* xpkchar - peek at a character from a file */
  316. NODE *xpkchar(args)
  317.   NODE *args;
  318. {
  319.     NODE *flag,*fptr,*val;
  320.     int ch;
  321.  
  322.     /* peek flag and get file pointer */
  323.     flag = (args ? xlarg(&args) : NIL);
  324.     fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  325.     xllastarg(args);
  326.  
  327.     /* skip leading white space and get a character */
  328.     if (flag)
  329.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  330.         xlgetc(fptr);
  331.     else
  332.     ch = xlpeek(fptr);
  333.  
  334.     /* check for eof */
  335.     if (ch == EOF)
  336.     val = NIL;
  337.     else {
  338.     val = newnode(INT);
  339.     val->n_int = ch;
  340.     }
  341.  
  342.     /* return the character */
  343.     return (val);
  344. }
  345.  
  346. /* xwrchar - write a character to a file */
  347. NODE *xwrchar(args)
  348.   NODE *args;
  349. {
  350.     NODE *fptr,*chr;
  351.  
  352.     /* get the character and file pointer */
  353.     chr = xlmatch(INT,&args);
  354.     fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
  355.     xllastarg(args);
  356.  
  357.     /* put character to the file */
  358.     xlputc(fptr,chr->n_int);
  359.  
  360.     /* return the character */
  361.     return (chr);
  362. }
  363.  
  364. /* xreadline - read a line from a file */
  365. NODE *xreadline(args)
  366.   NODE *args;
  367. {
  368.     NODE *oldstk,fptr,str;
  369.     char *p,*sptr;
  370.     int len,ch;
  371.  
  372.     /* create a new stack frame */
  373.     oldstk = xlsave(&fptr,&str,NULL);
  374.  
  375.     /* get file pointer */
  376.     fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  377.     xllastarg(args);
  378.  
  379.     /* make a string node */
  380.     str.n_ptr = newnode(STR);
  381.     str.n_ptr->n_strtype = DYNAMIC;
  382.  
  383.     /* get character and check for eof */
  384.     len = 0; p = buf;
  385.     while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
  386.  
  387.     /* check for buffer overflow */
  388.     if ((int)(p - buf) == STRMAX) {
  389.         *p = 0;
  390.          sptr = stralloc(len + STRMAX); *sptr = 0;
  391.         if (len) {
  392.         strcpy(sptr,str.n_ptr->n_str);
  393.         strfree(str.n_ptr->n_str);
  394.         }
  395.         str.n_ptr->n_str = sptr;
  396.         strcat(sptr,buf);
  397.         len += STRMAX;
  398.         p = buf;
  399.     }
  400.  
  401.     /* store the character */
  402.     *p++ = ch;
  403.     }
  404.  
  405.     /* check for end of file */
  406.     if (len == 0 && p == buf && ch == EOF) {
  407.     xlstack = oldstk;
  408.     return (NIL);
  409.     }
  410.  
  411.     /* append the last substring */
  412.     *p = 0;
  413.     sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
  414.     if (len) {
  415.     strcpy(sptr,str.n_ptr->n_str);
  416.     strfree(str.n_ptr->n_str);
  417.     }
  418.     str.n_ptr->n_str = sptr;
  419.     strcat(sptr,buf);
  420.  
  421.     /* restore the previous stack frame */
  422.     xlstack = oldstk;
  423.  
  424.     /* return the string */
  425.     return (str.n_ptr);
  426. }
  427.  
  428. /* getfile - get a file or stream */
  429. LOCAL NODE *getfile(pargs)
  430.   NODE **pargs;
  431. {
  432.     NODE *arg;
  433.  
  434.     /* get a file or stream (cons) or nil */
  435.     if (arg = xlarg(pargs)) {
  436.     if (filep(arg)) {
  437.         if (arg->n_fp == NULL)
  438.         xlfail("file not open");
  439.     }
  440.     else if (!consp(arg))
  441.         xlfail("bad argument type");
  442.     }
  443.     return (arg);
  444. }
  445.